(*
 *    #use "string.ml";;
 *)


#use "string.ml";;


module type SigOrd2String =
  sig
    type t
    
    val lt: t -> t -> bool
    val string_of_t: t -> string
    val t_of_string: string -> t
  end

module type SigMap =
  sig
    type key 
    type ('k , 'v) t
    
    exception KE
    exception KNE

    val createmap : (key , 'v) t

    val addmap : (key * 'v) -> (key , 'v) t -> (key , 'v) t

    val updatemap : (key * 'v) -> (key , 'v) t -> (key , 'v) t 

    val isinmap : key -> (key , 'v) t -> bool 

    val lookupmap : key -> (key , 'v) t -> 'v 

  end
 

module PrefixTree(KeyType: SigOrd2String) : SigMap  =
  struct
 
    type key = KeyType.t

    
          
    type 'v nodept = End of char * 'v 
                   | Node of char * 'v nodept list 
                   | NodeEnd of char * 'v * 'v nodept list 

    type ('k , 'v ) prefixtree = ('v nodept) list 


    type ('k , 'v) t = (key, 'v) prefixtree

    exception NP

    exception KE
    exception KNE


    let c2s c = Char.escaped c 



    let creatept = []

    
    let getkey node =
        match node with
          End(c,_) -> c
        | Node(c,_) -> c
        | NodeEnd(c,_,_) -> c 


    let rec insertpt (k,v) = 
        if (length k) > 1
           then 
              ( 
                let sk = sub k 1 (length k -1)
                in let st = [insertpt (sk,v) ]
                   in (Node(k.[0], st))
              )
           else (End(k.[0], v))


    let rec addpt ?(replace = false) (k,v) t  =
        match t with
          [] -> [insertpt (k,v) ]
        | x::y 
             -> ( match getkey x with 
                    c when(c <  k.[0]) 
                      -> x::(addpt ~replace:replace (k,v) y)
                  | c when(c >  k.[0])
                      -> let nn = insertpt (k,v) 
                         in nn::x::y
                  | c -> 
                         let lk = (length k) = 1
                         in let nn = (match x, lk with
                              End(ce, ve), true -> if replace
                                                      then End(c, v)
                                                      else raise  KE
                            | End(ce, ve), false -> let sk =  sub k 1 (length k -1)
                                                    in NodeEnd(ce,ve, [insertpt (sk,v)])

                            | Node(c, st), true -> NodeEnd(c,v,st)
                            | Node(c, st), false -> let sk = sub k 1 (length k -1)
                                                    in Node(c, addpt  ~replace:replace (sk,v) st)

                            | NodeEnd(ce, ve, st),true -> if replace
                                                             then NodeEnd(c,v,st)
                                                             else raise KE
                            | NodeEnd(ce, ve, st),false -> let sk = sub k 1 (length k -1)
                                                    in NodeEnd(ce, ve, addpt ~replace:replace (sk,v) st)
                         
                            ) in nn::y 
                 )

    let rec lookuppt k t =
        match t with
           [] -> None
        | x::y
             -> ( match getkey x with 
                    c when(c <  k.[0]) 
                      -> lookuppt k y
                  | c when(c >  k.[0])
                      -> None 
                  | c -> 
                         let lk = (length k) = 1
                         in (match x, lk with
                               End(ce, ve), true -> Some(ve)
                             | End(ce, ve), false -> None
   
                             | Node(c, st), true -> None
                             | Node(c, st), false -> let sk = sub k 1 (length k -1)
                                                     in lookuppt sk st
                             | NodeEnd(ce, ve, st),true -> Some(ve)
                             | NodeEnd(ce, ve, st),false -> let sk = sub k 1 (length k -1)
                                                     in lookuppt sk st
                          
                             )  
                 )


    let rec pt2list t =
        let rec aux t acc=
           match t with
             [] -> []
           | x::y 
                -> let xl = 
                      match x with
                        End(c,v) -> [(acc^(c2s c), v)]
                      | NodeEnd(c,v,st) -> (acc^(c2s c), v)::(aux st (acc^(c2s c)))
                      | Node(c,st)-> aux st (acc^(c2s c))
                   in xl@(aux y acc) 
        in aux t ""


    let list2pt l =
        let rec aux l t =
               match l with
                 [] -> t
               | x::y -> let nt = addpt x t 
                         in aux y nt
        in aux l (creatept) 


    let createmap = creatept

    let addmap (k,v) map = addpt ((KeyType.string_of_t k),v) map

    let updatemap (k,v) map = addpt ~replace:true ((KeyType.string_of_t k),v) map 

    let isinmap k map =
            match lookuppt (KeyType.string_of_t k) map with
               None -> false
            |  Some(_) -> true 

        
    let lookupmap k map =
        match lookuppt (KeyType.string_of_t k) map with
           None -> raise KNE 
        |  Some(v) -> v 

  end


module MyString : SigOrd2String = struct type t = string let lt = (<) let string_of_t t = t let t_of_string t = t end ;;
module MyMap = PrefixTree(MyString) ;;

let a = MyMap.createmap ;;
let a1 = MyMap.addmap ("ch1",1) a;;

